home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / INLINE / PEEK.S < prev    next >
Encoding:
Text File  |  1992-11-25  |  4.0 KB  |  121 lines
  1. ;* 
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Peek, poke, in & out implementation            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: M. Vuilleumier &    L.Bartholdi    Date: Nov 1992        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ; Let have...    0 <= address    <= #h10FFEF    (address > #hfffff cause A20)
  23. ;        0 <= X X1 .. Xn    <= #hFF[FF]    values read from memory
  24. ;        0 <= X Y1 .. Yn    <= #hFF[FF]    values to store in memory
  25. ;
  26. ; (peek 'BYTE address)        ---->    X        read a memory byte
  27. ; (peek 'WORD address)        ---->    X        read a memory word
  28. ; (peek 'BYTE address n)    ---->    '(X1 X2 ... Xn)    read a block of bytes
  29. ; (peek 'WORD address n)    ---->    '(X1 X2 ... Xn)    read a block of words
  30. ;
  31. ; (poke 'BYTE address Y)    ---->    X        store a memory byte
  32. ; (poke 'WORD address Y)    ---->    X        store a memory word
  33. ; (poke 'BYTE address 
  34. ;    '(Y1 Y2 .. Yn))     ---->    '(X1 X2 ... Xn)    store a block of bytes
  35. ; (poke 'WORD address 
  36. ;    '(Y1 Y2 .. Yn))     ---->    '(X1 X2 ... Xn)    store a block of words
  37. ;
  38. ;
  39. ; Now have...    0 <= Portnum    <= #hFFFF (usually Portnum <= #h3FF)
  40. ;        0 <= DataByte    <= #hFF        to read from/write to port
  41. ;        0 <= DataWord    <= #hFFFF    to read from/write to port
  42. ;
  43. ; (in-port 'BYTE Portnum)    ---->    DataByte    read a byte from port
  44. ; (in-port 'WORD Portnum)    ---->    DataWord    read a word from port
  45. ;
  46. ; (out-port 'BYTE Portnum DataByte) ----> undefined    write a byte to port
  47. ; (out-port 'WORD Portnum WordByte) ----> undifined    write a word to port
  48.  
  49. (if (unbound? peekbyte)
  50.   (load (%system-file-name "peek.bin")))
  51.  
  52. (define peek)
  53. (define poke)
  54. (define in-port)
  55. (define out-port)
  56.  
  57. (let
  58.   ((range
  59.      (lambda (n max)
  60.        (if (number? n) (and (>= n 0)
  61.                 (<= n max)))))
  62.    (error!
  63.      (lambda (proc . args)
  64.        (%error-invalid-operand proc (cons proc args)))))
  65.  
  66.   (set! peek
  67.     (lambda (size adr . n)
  68.       (cond ((eq? (car n) 0)         '())
  69.         ((not (range adr #h10ffef))    (error! 'peek size adr '...))
  70.         ((null? n)
  71.          (cond
  72.            ((eq? size 'BYTE)    (peekbyte adr))
  73.            ((eq? size 'WORD)    (+ (* (peekbyte (1+ adr)) #h100)
  74.                        (peekbyte adr)))
  75.            (else            (error! 'peek size '...))))
  76.         ((not (range (car n) #h10ffef)) (error! 'peek size adr n))
  77.         (else
  78.              (cons (peek size adr) 
  79.            (peek size (+ adr (if (eq? size 'BYTE) 1 2)) 
  80.                   (-1+ (car n))))))))
  81.  
  82.   (set! poke
  83.     (lambda (size adr data)
  84.       (cond ((null? data)        '())
  85.         ((not (range adr #h10ffef))    (error! 'poke size adr '...))
  86.         ((and (eq? size 'BYTE)
  87.           (range data #hff))    (pokebyte adr data))
  88.         ((and (eq? size 'WORD)
  89.           (range data #hffff))    (+ (* (pokebyte (1+ adr) (quotient data #h100)) #h100)
  90.                        (pokebyte adr (remainder data #h100))))
  91.         ((atom? data)        (error! 'poke size adr data))
  92.         (else
  93.           (cons (poke size adr (car data)) 
  94.             (poke size (+ adr (if (eq? size 'BYTE) 1 2)) (cdr data)))))))
  95.  
  96.   (set! in-port
  97.     (lambda (size pnum)
  98.       (cond ((not (range pnum #hffff))    (error! 'in-port size pnum))
  99.         ((eq? size 'BYTE)        (inbyte pnum))
  100.         ((eq? size 'WORD)        (inword pnum))
  101.         (else            (error! 'in-port size '...)))))
  102.  
  103.   (set! out-port
  104.     (lambda (size pnum data)
  105.       (cond ((not (range pnum #hffff))    (error! 'out-port size pnum '...))
  106.         ((eq? size 'BYTE)        (if (range data #hff)
  107.                         (outbyte pnum data)
  108.                         (error! 'out-port size pnum data)))
  109.         ((eq? size 'WORD)        (if (range data #hffff)
  110.                         (outword pnum data)
  111.                         (error! 'out-port size pnum data))
  112.         (else            (error! 'out-port size '...))))))
  113.  
  114. )
  115.  
  116.  
  117.  
  118.  
  119.      
  120.  
  121.